;; This file is part of Scheme-GNUnet.
;; Copyright © 2022 GNUnet e.V.
;;
;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; Scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later
(define-library (gnu gnunet cadet client)
  (export connect disconnect!
	  make-cadet-address cadet-address? cadet-address-peer cadet-address-port
	  channel? open-channel! close-channel!
	  port? open-port! close-port!
	  %max-cadet-message-size

	  ;; Network manipulation procedures
	  ;; (these belong to (gnu gnunet cadet network)).
	  (rename (analyse-local-channel-create
		   #{ analyse-local-channel-create}#)
		  (construct-local-channel-create
		   #{ construct-local-channel-create}#)
		  (analyse-local-channel-destroy
		   #{ analyse-local-channel-destroy}#)
		  (construct-local-channel-destroy
		   #{ construct-local-channel-destroy}#)
		  (analyse-local-data #{ analyse-local-data}#)
		  (construct-local-data #{ construct-local-data}#)
		  (analyse-local-acknowledgement
		   #{ analyse-local-acknowledgement}#)
		  (construct-local-acknowledgement
		   #{ construct-local-acknowledgement}#)))
  (import (only (gnu extractor enum)
		value->index symbol-value)
	  (only (gnu gnunet cadet struct)
		/:msg:cadet:local:channel:create
		/:msg:cadet:local:channel:destroy
		/:msg:cadet:local:data
		/:msg:cadet:local:acknowledgement)
	  (only (gnu gnunet crypto struct)
		/peer-identity)
	  (only (gnu gnunet concurrency lost-and-found)
		make-lost-and-found collect-lost-and-found-operation)
	  (only (gnu gnunet mq handler) message-handlers)
	  (only (gnu gnunet mq) close-queue! send-message!)
	  (only (gnu gnunet server)
		maybe-send-control-message!* make-error-handler)
	  (only (gnu gnunet hashcode struct)
		/hashcode:512)
	  (only (gnu gnunet message protocols) message-type)
	  (only (gnu gnunet mq-impl stream) connect/fibers)
	  (only (gnu gnunet netstruct syntactic)
		sizeof select read% set%!)
	  (only (gnu gnunet utils bv-slice)
		make-slice/read-write slice-copy/read-only slice-length
		slice-copy! slice-slice)
	  (only (gnu gnunet utils cut-syntax)
		cut-syntax)
	  (only (gnu gnunet utils hat-let)
		let^)
	  (only (rnrs base)
		begin define lambda assert quote cons apply values
		case else = define-syntax + expt - let* let and)
	  (only (rnrs records syntactic) define-record-type)
	  (only (ice-9 match) match)
	  (only (guile) define*)
	  (only (fibers) spawn-fiber)
	  (only (fibers channels) get-operation put-operation make-channel)
	  (only (fibers conditions) make-condition wait-operation
		signal-condition!)
	  (only (fibers operations)
		wrap-operation choice-operation perform-operation))
  (begin
    ;; TODO: deduplicate these two procedures with (gnu gnunet dht client)
    (define (maybe-send-control-message! server . message)
      (apply maybe-send-control-message!* (server-terminal-condition server)
	     (server-control-channel server) message))
    (define (disconnect! server)
      (maybe-send-control-message! server 'disconnect!))

    (define-record-type (<server> %make-server server?)
      (parent <losable>)
      (fields (immutable lost-and-found server-lost-and-found)
	      (immutable terminal-condition server-terminal-condition)
	      (immutable control-channel server-control-channel))
      (protocol (lambda (%make)
		  (lambda ()
		    (define lost-and-found (make-lost-and-found))
		    ((%make lost-and-found) lost-and-found (make-condition)
		     (make-channel))))))

    (define-record-type (<channel> %make-channel channel?)
      (parent <losable>)
      (fields (immutable server channel-server) ; <server>
	      (immutable destination channel-address) ; <cadet-address>
	      (immutable options channel-options)
	      ;; Initially #false, when no channel number has been chosen yet
	      ;; by the client.  When the control loop accepts the <channel>,
	      ;; a channel number is assigned.  After a reconnect, channel
	      ;; numbers are reset.
	      (mutable channel-number channel-channel-number
		       set-channel-channel-number!))
      (protocol (lambda (%make)
		  (lambda (server destination options)
		    ((%make (server-lost-and-found server)) server
		     destination options #false)))))

    (define* (connect config #:key (connected values) (disconnected values)
		      (spawn spawn-fiber))
      "Asynchronuously connect to the CADET service, using the configuration
@var{config}, returning a CADET server object."
      (define server (%make-server))
      (spawn-procedure spawn config
		       (server-terminal-condition server)
		       (server-control-channel server)
		       connected disconnected spawn
		       (server-lost-and-found server))
      server)

    ;; TODO: reduce duplication with (gnu gnunet dht client)
    (define (spawn-procedure spawn . rest)
      (spawn (lambda () (apply reconnect rest))))
    (define (disconnect! server)
      (maybe-send-control-message! server 'disconnect!))

    (define (reconnect config terminal-condition control-channel
		       connected disconnected spawn
		       lost-and-found)
      (define loop-operation
	(choice-operation
	 (get-operation control-channel)
	 (wrap-operation (collect-lost-and-found-operation lost-and-found)
			 (lambda (lost) (cons 'lost lost)))))
      (define handlers (message-handlers)) ; TODO
      (define error-handler
	(make-error-handler connected disconnected terminal-condition
			    control-channel))
      (define mq (connect/fibers config "cadet" handlers error-handler
				 #:spawn spawn))
      (define (control next-free-channel-number)
	"The main event loop."
	(control* next-free-channel-number
		  (perform-operation loop-operation)))
      (define (control* next-free-channel-number message)
	(define (continue)
	  (control next-free-channel-number))
	(define (continue* message)
	  (control* next-free-channel-number message))
	(match message
	  (('disconnect!)
	   ;; Ignore future requests instead of blocking.
	   (signal-condition! terminal-condition)
	   ;; Close networking ports.
	   (close-queue! mq)
	   ;; And the fibers of the <server> object are now done!
	   (values))
	  (('open-channel! channel)
	   (let* ((channel-number next-free-channel-number)
		  ;; TODO: handle overflow, and respect bounds
		  (next-free-channel-number (+ 1 next-free-channel-number)))
	     (set-channel-channel-number! channel channel-number)
	     (send-local-channel-create! mq channel)
	     (control next-free-channel-number)))
	  (('close-channel! channel) TODO)
	  (('lost . lost)
	   (let loop ((lost lost))
	     (match lost
	       (() (continue))
	       ((object . rest)
		(match object
		  ((? channel? lost)
		   TODO
		   (loop rest))
		  ((? server? lost)
		   (continue* '(disconnect!))))))))))
      ;; Start the main event loop.
      (control 0))

    (define-record-type (<cadet-address> make-cadet-address cadet-address?)
      (fields (immutable peer cadet-address-peer)
	      (immutable port cadet-address-port))
      (protocol (lambda (%make)
		  "Make a CADET address for contacting the peer @var{peer}
(a readable bytevector slice containing a @code{/peer-identity}) at port
@var{port} (a readable bytevector slice containing a @code{/hashcode:512}).
The slices @var{peer} and @var{port} are copied, so future changes to them
do not have any impact on the cadet address."
		  (lambda (peer port)
		    (assert (= (sizeof /peer-identity '()) (slice-length peer)))
		    (assert (= (sizeof /hashcode:512 '()) (slice-length port)))
		    (%make (slice-copy/read-only peer)
			   (slice-copy/read-only port))))))

    (define* (construct-local-channel-create cadet-address channel-number
					     #:optional (options 0))
      "Create a new @code{/:msg:cadet:channel:create} message for contacting
the CADET addresss @var{cadet-address}, using the channel number
@var{channel-number} and options @var{options}."
      (define s
	(make-slice/read-write (sizeof /:msg:cadet:local:channel:create '())))
      (define-syntax set*
	(cut-syntax set%! /:msg:cadet:local:channel:create <> s <>))
      (define-syntax select*
	(cut-syntax select /:msg:cadet:local:channel:create <> s))
      (set* '(header size) (slice-length s))
      (set* '(header type)
	    (value->index
	     (symbol-value message-type msg:cadet:local:channel:create)))
      (set* '(channel-number) channel-number)
      (slice-copy! (cadet-address-peer cadet-address) (select* '(peer)))
      (slice-copy! (cadet-address-port cadet-address) (select* '(port)))
      (set* '(options) options)
      s)

    (define (send-local-channel-create! mq channel)
      (send-message!
       mq (construct-local-channel-create
	   (channel-address channel) (channel-channel-number channel))))

    (define (analyse-local-channel-create message)
      "Return the CADET address, channel number and options corresponding to
the @code{/:msg:cadet:channel:create} message @var{message}."
      (define-syntax read*
	(cut-syntax read% /:msg:cadet:local:channel:create <> message))
      (define-syntax select*
	(cut-syntax select /:msg:cadet:local:channel:create <> message))
      (let^ ((! channel-number (read* '(channel-number)))
	     (! peer (select* '(peer)))
	     (! port (select* '(port)))
	     (! channel-number (read* '(channel-number)))
	     (! options (read* '(options)))
	     (! address (make-cadet-address peer port)))
	    (values address channel-number options)))

    (define (construct-local-channel-destroy channel-number)
      "Create a @code{/:msg:cadet:channel:destroy} message for closing the
CADET channel with channel number @var{channel-number}."
      (define s
	(make-slice/read-write (sizeof /:msg:cadet:local:channel:destroy '())))
      (define-syntax set*
	(cut-syntax set%! /:msg:cadet:local:channel:destroy <> s <>))
      (set* '(header size) (slice-length s))
      (set* '(header type)
	    (value->index
	     (symbol-value message-type msg:cadet:local:channel:destroy)))
      (set* '(channel-number) channel-number)
      s)

    (define (analyse-local-channel-destroy message)
      "Return the channel number corresponding to the
@code{/:msg:cadet:local:channel:destroy} message @var{message}."
      (read% /:msg:cadet:local:channel:destroy '(channel-number) message))

    ;; TODO: determine maximum length
    (define %max-cadet-message-size
      (- (- (expt 2 16) 1) (sizeof /:msg:cadet:local:data '())))

    ;; would be nice to avoid copying
    ;; TODO: direction (service->client, client->service?)
    (define (construct-local-data channel-number priority-preference data)
      "Create a @code{/:msg:cadet:local:data} message ???"
      (define header-size (sizeof /:msg:cadet:local:data '()))
      (define s (make-slice/read-write (+ header-size (slice-length data))))
      (define header (slice-slice s 0 header-size))
      (define rest (slice-slice s header-size))
      (define-syntax set*
	(cut-syntax set%! /:msg:cadet:local:data <> header <>))
      (set* '(header size) (slice-length s))
      (set* '(header type)
	    (value->index
	     (symbol-value message-type msg:cadet:local:data)))
      (set* '(channel-number) channel-number)
      (set* '(priority-preference) priority-preference)
      (slice-copy! data rest)
      s)

    (define (analyse-local-data message)
      "Return the channel number, the numeric priority-preference value and data
in the @code{/:msg:cadet:local:data} message @var{message}."
      (define header
	(slice-slice message 0 (sizeof /:msg:cadet:local:data '())))
      (define-syntax read*
	(cut-syntax read% /:msg:cadet:local:data <> header))
      (define-syntax select*
	(cut-syntax select /:msg:cadet:local:data <> header))
      (values (read* '(channel-number))
	      (read* '(priority-preference))
	      (slice-slice message
			   (sizeof /:msg:cadet:local:data '()))))

    (define (construct-local-acknowledgement channel-number)
      "Create a @code{/:msg:cadet:local:acknowledgement} message,
to inform the client that more data can be sent across the channel
identified by @var{channel-number}."
      (define s
	(make-slice/read-write (sizeof /:msg:cadet:local:acknowledgement '())))
      (define-syntax set*
	(cut-syntax set%! /:msg:cadet:local:acknowledgement <> s <>))
      (set* '(header size) (slice-length s))
      (set* '(header type)
	    (value->index
	     (symbol-value message-type msg:cadet:local:acknowledgement)))
      (set* '(client-channel-number) channel-number)
      s)

    (define (analyse-local-acknowledgement message)
      "Return the channel number in the @code{/:msg:cadet:local:data}
message @var{message}."
      (read% /:msg:cadet:local:acknowledgement '(client-channel-number) message))

    (define (stub . foo)
      (error "todo"))
    (define channel? stub)

    ;; TODO: callbacks, message queue, actually test it
    (define* (open-channel! server address)
      (assert (and (server? server) (cadet-address? address)))
      (define channel (%make-channel server address 0))
      (maybe-send-control-message! server 'open-channel! channel)
      channel)

    ;; TODO: call when mq is closed, maybe unify closing the message queue
    ;; and the channel?
    (define (close-channel! channel)
      (assert (channel? channel))
      (maybe-send-control-message! (channel-server channel) 'close-channel!
				   channel))
    (define port? stub)
    (define open-port! stub)
    (define close-port! stub)))
